home *** CD-ROM | disk | FTP | other *** search
/ Mac Mania 2 / MacMania 2.toast / Demo's / Tools&Utilities / Programming / PowerLisp 1.1 / Library / compiler.lisp < prev    next >
Encoding:
Text File  |  1994-03-25  |  51.7 KB  |  2,021 lines  |  [TEXT/ROSA]
  1. ;;;
  2. ;;;        Copyright © 1994 Roger Corman.  All rights reserved.
  3. ;;;
  4.  
  5. ;
  6. ;    Source code for compiler.
  7. ;    This is included in the "COMPILER" package.
  8. ;
  9.  
  10. (eval-when (:compile-toplevel :load-toplevel :execute)
  11.     (provide :compiler)
  12.     (in-package :compiler)
  13.     (require :assembler)
  14.     (use-package :assembler)
  15.     (export '(compiler::compile-top-level-form)))
  16.  
  17. (eval-when (:compile-toplevel :load-toplevel :execute)
  18.     (defun assembly-start (stream char)
  19.         (cons 'compiler::push-assembly-instructions (read-delimited-list #\] stream)))
  20.     (defun assembly-end (stream char) nil)
  21.     (set-macro-character #\[ #'assembly-start)
  22.     (set-macro-character #\] #'assembly-end))
  23.  
  24. ;
  25. ;    We do an eval-when on the entire file so that we get the
  26. ;    performance benefits immediately
  27. ;
  28. (eval-when (:compile-toplevel :load-toplevel :execute)
  29.     
  30. (defvar *assemble-code* t)
  31. (defvar *asm* nil)
  32. (defvar *lex-counter* 0)
  33. (defvar *references* nil)
  34. (defvar *function-name* nil)
  35. (defvar *function-entry-label* nil)
  36. (defvar *cleanup-forms-stack* nil)
  37. (defvar *lambda-list* nil)
  38. (defvar *arg-count* 0)
  39. (defvar *last-call-was-values* nil)
  40. (defvar *environment* nil)
  41. (defvar *embedded-lambdas* nil)
  42. (defvar *lambda-special-vars* nil)
  43. (defvar *lambda-declarations* nil)
  44. (defvar *lambda-special-decs* nil)
  45. (defvar *compile-time-too-mode* nil) 
  46. (defvar *compile-print* nil)
  47. (defvar *compile-output-file* nil)
  48. (defvar *symbol-table* nil)
  49. (defvar *last-call-was-tail-recursion* nil)
  50.  
  51. ;; top level forms which we will output the names of while compiling
  52. ;; if *compile-print* is true
  53. (defvar *compiler-print-forms* 
  54.     '(defun defmacro defstruct defclass defvar defparameter defconstant))
  55.  
  56. (defun compile-it (name &optional lambda &aux (macro nil))
  57.     (unless (typep name 'symbol) (error "Function name expected"))
  58.     (unless lambda (setf lambda (function-definition (symbol-function name))))
  59.     (setq macro (macro-function name))
  60.     (unless (eq (car lambda) 'lambda) (error "Not a lambda expression"))
  61.     (setq *assemble-code* t)
  62.     (if macro
  63.         (setf (macro-function name) (compile-lambda lambda name))
  64.         (setf (symbol-function name) (compile-lambda lambda name)))
  65.     name)
  66.  
  67. (defun compile-without-assembling-it (name &optional lambda &aux (macro nil))
  68.     (unless (typep name 'symbol) (error "Function name expected"))
  69.     (unless lambda (setf lambda (function-definition (symbol-function name))))
  70.     (setq macro (macro-function name))
  71.     (unless (eq (car lambda) 'lambda) (error "Not a lambda expression"))
  72.     (setq *assemble-code* nil)
  73.     (compile-lambda lambda name))
  74.  
  75. (defun compile-the-file (input-file output-file print)
  76.     (setq *assemble-code* t)
  77.     (do* ((infile (open input-file)) 
  78.           (*compile-output-file* (progn (delete-file output-file) (open output-file)))
  79.           (*compile-print* print)
  80.           (*package* *package*)
  81.           (*readtable* *readtable*)
  82.           (*symbol-table* (make-hash-table :size 500))
  83.           (input-expression (read infile) (read infile))
  84.           code
  85.           return-value)
  86.          ((eq input-expression 'Eof) 
  87.             (close infile)
  88.             (set-file-type *compile-output-file* "FASL")
  89.             (close *compile-output-file*)
  90.             output-file)
  91.         
  92.         (process-top-level-forms (list input-expression))))
  93.  
  94. ;;
  95. ;;    The following logic is taken from CLTL2 pp.90-91
  96. ;;
  97. (defun process-top-level-forms (forms &aux code return-value print-form)
  98.     (dolist (f forms)
  99.         (setq print-form nil)
  100.         (if (not (consp f)) (go continue))    ;; no need to process non-list forms
  101.             
  102.         (if (and *compile-print*
  103.                 (member (car f) *compiler-print-forms*) 
  104.                 (consp (cdr f)))
  105.             (setq print-form (list (car f) (cadr f) "...")))
  106.  
  107.         (if (macro-function (car f)) ;; if it is a macro expand it
  108.             (progn
  109.                 (setq f (macroexpand f))
  110.                 (if (not (consp f)) (go continue)))) ;; no need to process non-list forms
  111.  
  112.         ;; watch for some special forms
  113.         (if (special-form-p (car f))
  114.  
  115.             (progn
  116.                 ;; if a progn or locally special form, recurse
  117.                 (if (or (eq (car f) 'common-lisp::progn) 
  118.                         (eq (car f) 'common-lisp::locally))
  119.                     (progn
  120.                         (process-top-level-forms (cdr f))
  121.                         (go continue)))
  122.  
  123.                 ;; if compiler-let, macrolet or symbol-macrolet
  124.                 (if (or (eq (car f) 'common-lisp::compiler-let)
  125.                         (eq (car f) 'common-lisp::macrolet)  
  126.                         (eq (car f) 'common-lisp::symbol-macrolet))
  127.                     (progn
  128.                         (error "Compiler does not support special form: ~A" (car f))
  129.                         (process-top-level-forms (cdr f))
  130.                         (go continue)))
  131.     
  132.                 ;; if eval-when
  133.                 (if (eq (car f) 'common-lisp::eval-when)
  134.                     (progn
  135.                         (compile-top-level-eval-when-form f)
  136.                         (go continue)))))
  137.  
  138.         ;; else it is not a special case
  139.  
  140.         ;; now compile it
  141.         (setq code (compile-top-level-form f))
  142.         (%write-code-to-stream code *compile-output-file* *symbol-table*)
  143.  
  144.         ;; evaluate the form if compile-time-too mode
  145.         (if *compile-time-too-mode*
  146.             (setq return-value (funcall code)))
  147.  
  148. continue
  149.         (if print-form
  150.              (progn
  151.                 (format t "~A~%" print-form)
  152.                 (file-flush)))))
  153.  
  154. (defun compile-top-level-eval-when-form (form)
  155.     (if (or (not (consp form)) (< (length form) 2) (not (listp (cadr form))))
  156.         (error "'eval-when' form missing condition list."))
  157.  
  158.     (let* ((conditions (cadr form))
  159.            (load-condition 
  160.             (or (member 'common-lisp::load conditions) 
  161.                 (member :load-toplevel conditions)))
  162.            (eval-condition 
  163.             (or (member 'common-lisp::eval conditions) 
  164.                 (member :execute conditions)))
  165.            (compile-condition 
  166.             (or (member 'common-lisp::compile conditions) 
  167.                 (member :compile-toplevel conditions))))
  168.  
  169.         (if load-condition
  170.             (if (or compile-condition 
  171.                     (and *compile-time-too-mode* eval-condition))
  172.                 (let ((*compile-time-too-mode* t))
  173.                     (process-top-level-forms (cddr form)))
  174.                 (let ((*compile-time-too-mode* nil))
  175.                     (process-top-level-forms (cddr form))))
  176.  
  177.             ;; load not specified
  178.             (if (or compile-condition 
  179.                     (and *compile-time-too-mode* eval-condition))
  180.                 (eval form)))))            
  181.     
  182. ;;
  183. ;;    The cleanup forms stack needs to be maintained for use in non-local
  184. ;;    lexically scoped exit situations. Specifically, GO with a target outside
  185. ;;    the current construct, and RETURN-FROM when exiting an external construct.
  186. ;;    Note that THROW targets are dynamic, not lexical, and therefore cannot
  187. ;;    be handled at compile time. They are handled via a different mechanism, a
  188. ;    run-time stack. Lexically scoped exits are better handled at compile time,
  189. ;;    both for efficiency (a big concern, because GO is the primary iteration 
  190. ;;    facility) and because the lexical scoping is currently only known at
  191. ;;    compile-time. In other words, a run-time lexical environment is not maintained
  192. ;;    for compiled code, and for efficiency reasons it would be better not to have
  193. ;;    to.
  194. ;;
  195. ;;    Entries on the cleanup forms stack include:
  196. ;;
  197. ;;    (BLOCK block-name block-exit-label)
  198. ;;    (TAGBODY (local-tag-1 . local-label-1) (local-tag-2 . local-label-2) ...)
  199. ;;    (LET (local-var-1 . index1) (local-var-2 . index2) ...)
  200. ;;        (the LET form is used by both LET *and* LET* forms)
  201. ;;    (CATCH catch-tag)
  202. ;;    (UNWIND-PROTECT <compiled code to be included>)
  203. ;; 
  204.  
  205. (defconstant *lambda-list-keywords* 
  206.         '(    &optional 
  207.             &rest 
  208.             &key 
  209.             &aux 
  210.             &allow-other-keys
  211.             &whole
  212.             &body ))
  213.  
  214. ;; the following aren't allowed in lambda function declarations
  215. ;; (only in macros, which will be expanded before we see them)
  216. (defconstant *unsupported-lambda-list-keywords* 
  217.         '(  &allow-other-keys
  218.             &whole
  219.             &body ))
  220.  
  221. ;;
  222. ;;    Set up square braces as assembly delimiters for this module
  223. ;;    This helps to clearly distinguish the generated code from the
  224. ;;    surrounding stuff.
  225. ;;
  226. (defun push-assembly-instructions (&rest instructions)
  227.     (dolist (x instructions)
  228.         (push x *asm*)))
  229.  
  230. (defun push-cleanup (x) (push x *cleanup-forms-stack*))
  231. (defun pop-cleanup () (pop *cleanup-forms-stack*))
  232.  
  233. ;;    We use the following registers:
  234. ;;    A0, D0 : scratch registers. D0 ultimately returns the value.
  235. ;;    D3 : stores last returned value
  236. ;;    A2 : used as local index for function call
  237. ;;    A3 : points to lexical storage for the function
  238. ;;    A4 : points to function's environment (variables with indefinite extent)
  239. ;;    A6 : links previous stack frame
  240. ;;    A7 : stack pointer
  241. ;;    A5 : global variables
  242. ;;    
  243. ;;    We do not need to save A5, A6 or A7
  244. ;;    We also don't need to save scratch register D0.
  245. ;;    We *do* need to save A0, A2, A3 and D3.
  246. ;;
  247.             
  248. ;;
  249. ;;    compile-top-level-form (form &optional (assemble t))
  250. ;;    Given an arbitrary lisp form, returns a compiled function 
  251. ;;    equivalent to it.
  252. ;;
  253. (defun compile-top-level-form (form)
  254.     (let* (
  255.            ;; Establish local bindings of these special variables
  256.            ;; so that this function can be entered recursively.
  257.            ;;
  258.            (*asm* nil)
  259.            (*lex-counter* 0)
  260.            (*references* nil)
  261.            (*function-entry-label* (gensym))
  262.            (*last-call-was-values* nil)
  263.            (*cleanup-forms-stack* nil)
  264.            (*environment* nil)
  265.            (*embedded-lambdas* (find-lambdas form)))    
  266.            
  267.         ;; emit code for function prolog
  268. ;;        [ `(link a6 ,(- (* numargs 4))) ]     ;; this is added at end
  269.         (emit-prolog)
  270.                 
  271.         ;; compile the form
  272.         (compile-form form)
  273.  
  274.         ;; make sure bogus multiple values don't get returned
  275.         (unless *last-call-was-values* (kill-multiple-values))
  276.  
  277.         (emit-epilog)        
  278.         
  279.         ;; if we don't want to assemble it, exit here
  280.         (if *assemble-code* 
  281.             (return (assemble *asm* *references* nil))            
  282.             (return *asm*))))
  283.  
  284.  
  285. ;;---------------------------------------------------
  286. ;;
  287. ;;    compile-lambda (lambda)
  288. ;;    Given a lambda expression, returns a compiled function.
  289. ;;
  290. (defun compile-lambda (lambda func-name)
  291.     (check-lambda lambda)            ;; make sure we can compile it    
  292.     (let* ((*asm* nil)
  293.            (*references* nil)
  294.            (*function-name* func-name)
  295.            (*function-entry-label* (gensym))
  296.            (*cleanup-forms-stack* nil)
  297.            (*lambda-list* (cadr lambda))
  298.            (*last-call-was-values* nil)
  299.            (*environment* *environment*)    ;; inherit from enclosing expression
  300.            (*embedded-lambdas* (find-lambdas (cdr lambda)))    
  301.            (*arg-count* 0)
  302.            (*lex-counter* 0)
  303.            (*lambda-special-vars* nil)
  304.            (*lambda-declarations* nil)            
  305.            (*lambda-special-decs* nil)
  306.            (*last-call-was-tail-recursion* nil)            
  307.            (forms (cddr lambda))
  308.            (new-vars (collect-new-vars *lambda-list*))
  309.            (lex-vars nil)
  310.            (aux-args (aux-arguments *lambda-list*)))
  311.  
  312.         ;; look for declarations
  313.         (do ((f forms (cdr f)))
  314.             ((null f) (setq forms f))
  315.             (if (and (consp (car f)) (eq (caar f) 'declare))
  316.                 (push (car f) *lambda-declarations*)
  317.                 (progn (setq forms f) (return))))
  318.  
  319.         ;; search declarations for special declarations
  320.         (dolist (declaration *lambda-declarations*)
  321.             (dolist (dec-form (cdr declaration))
  322.                 (if (and (consp dec-form) (eq (car dec-form) 'special))
  323.                     (setq *lambda-special-decs*
  324.                         (append (cdr dec-form) *lambda-special-decs*)))))
  325.  
  326.         (setq lex-vars 
  327.             (remove-if 
  328.                 #'(lambda (x) 
  329.                     (or (member x *lambda-special-decs*)
  330.                         (special-variable-p x)))
  331.                 new-vars
  332.                 :key #'car))
  333.  
  334.         (add-lexical-variables lex-vars)
  335.  
  336.         (emit-prolog)
  337.         (compile-lambda-args)
  338.         (create-runtime-bindings)    ;; create necessary heap bindings
  339.         
  340.         ;; handle aux variables by just adding an implicit let* form
  341.         (if aux-args
  342.             (setf forms `((let* ,aux-args ,@forms))))
  343.             
  344.         (compile-nil)        ;; store NIL as default return value
  345.                 
  346.  
  347.         (if *lambda-special-vars*
  348.             (compile-unwind-protect-form 
  349.                 `(unwind-protect 
  350.                     (block ,func-name ,@forms)
  351.                     ($pop-special-bindings ',*lambda-special-vars*)))
  352.  
  353.             ;; else execute the forms directly
  354.             ;; compile the forms as a block
  355.             (compile-block-form `(block ,func-name ,@forms)))
  356.  
  357.         ;; eliminate tail recursion
  358.         (if *last-call-was-tail-recursion*
  359.             (let* ((num-call-instructions (- (length *asm*) (length *last-call-was-tail-recursion*)))
  360.                    (call-instructions (reverse (subseq *asm* 0 num-call-instructions)))
  361.                    (find-top-label (gensym))
  362.                    (copy-label))
  363.  
  364.                 ;; strip off the function call
  365.                 (setq *asm* *last-call-was-tail-recursion*)
  366.  
  367.                 ;; push all instructions up to the bsr
  368.                 (do ((inst (pop call-instructions) (pop call-instructions)))
  369.                     ((or (null call-instructions) 
  370.                         (and (consp inst) (eq (car inst) 'assembler::bsr))))
  371.                     (push inst *asm*))
  372.  
  373.                 ;; move passed params to outer stack frame
  374.                 ;; add return address and branch instruction to simulate jsr
  375.                 [
  376.                     `(move.l a7 a3)
  377.                     
  378.                     ;; position a3 above top of parameter frame
  379.                     find-top-label        
  380.                     `(tst.l (a3+))
  381.                     `(bne ,find-top-label)
  382.  
  383.                     ;; copy parameters
  384.                     copy-label
  385.                     `(move.l (-a3) (-a2))
  386.                     `(move.l a3 d0)            ;; haven't implemented cmpa.l instruction yet
  387.                     `(cmp.l a7 d0)
  388.                     `(bne ,copy-label)
  389.                     `(unlk a6)
  390.                     `(move.l (a7) a0)            ; get return address in a0
  391.                     `(lea (a2 4) a7)
  392.                     `(move.l a7 (-a7))
  393.                     `(move.l a0 (-a7))
  394.                     `(bra ,*function-entry-label*)
  395.                 ]
  396.                 
  397.                 ;; add the rest of the instructions
  398.                 (do ((inst (pop call-instructions) (pop call-instructions)))
  399.                     ((null call-instructions)) 
  400.                     (push inst *asm*))))
  401.                 
  402.         ;; make sure bogus multiple values don't get returned
  403.         (unless *last-call-was-values* (kill-multiple-values))
  404.  
  405.         (emit-epilog)
  406.         (pop-cleanup)        
  407.         (if *assemble-code* 
  408.             (return (assemble *asm* *references* nil))            
  409.             (return *asm*))))
  410.  
  411.  
  412. (defun compile-lambda-args ()
  413.     (compile-lambda-required-args)
  414.     (compile-lambda-optional-args)
  415.     (compile-lambda-rest-args)        
  416.     (check-no-more-args)
  417.     (compile-lambda-key-args))
  418.     
  419.  
  420. (defun collect-new-vars (lambda-list)
  421.     (let ((new-vars nil)(supplied_p_vars nil))
  422.         (dolist (n lambda-list)                    ;; add lexical vars
  423.             (if (not (member n *lambda-list-keywords*))
  424.                 (progn
  425.                     (if (consp n)
  426.                         (progn
  427.                             (if (>= (length n) 3)        ;; get supplied_p symbols
  428.                                 (push (caddr n) supplied_p_vars))
  429.                             (push (cons (car n) *lex-counter*) new-vars))
  430.                         (push (cons n *lex-counter*) new-vars))
  431.                     (incf *lex-counter*))))
  432.         (dolist (n supplied_p_vars)
  433.             (push (cons n *lex-counter*) new-vars)    ;; these need to go on the end
  434.             (incf *lex-counter*))
  435.         (nreverse new-vars)))                        
  436.  
  437.  
  438. ;; emit code for start of function            
  439. (defun emit-prolog ()
  440.     [ 
  441.         `(movem.l    a0 a2 a3 a4 d3 (-a7)) 
  442.     ]
  443.  
  444.     (if (or *embedded-lambdas* *environment*)
  445.     [
  446.         `(bsr 2)                        ; push current pc on stack
  447.         `(move.l (a7+) a4)                ; a4 = pc
  448.         `(move.l (a4 -16) a4)            ; a4 = pointer to environment (just before code)
  449.         
  450.     ])
  451.     
  452.     [
  453.         `(movea.l (a6 8) a2)            ; a2 = a6 + 8 = parameter block
  454.         `(lea (a7 20) a3)                ; a3 = pointer to local arguments
  455.                                         ; the offset to a7 should be 4 * number of
  456.                                         ; registers saved!
  457.     ])
  458.  
  459.  
  460. ;; emit code for end of function            
  461. (defun emit-epilog ()
  462.     [
  463.         `(move.l d3 d0)
  464.         `(movem.l (a6 ,(- -20 (* *lex-counter* 4))) a0 a2 a3 a4 d3)
  465.         `(unlk a6)                        ; unlink frame pointer
  466.         `(rts)                            ; d0 already contains return value
  467.     ]
  468.     
  469.     (setq *asm* (nreverse *asm*))
  470.  
  471.     ;; These last instructions get pushed onto the beginning
  472.     ;; of the (now-reversed) instructions. Therefore they are reversed
  473.     ;; here to come out in the right order.
  474.     [
  475.         `(link a6 ,(- (* *lex-counter* 4)))
  476.         *function-entry-label*
  477.     ]    
  478. )
  479.  
  480.  
  481. ;; Make sure there are no more arguments.
  482. (defun check-no-more-args ()
  483.     (if (not (or (rest-arguments *lambda-list*) (key-arguments *lambda-list*)))
  484.         [
  485.             `(move.l (a2+) (-a7))                ; get argument
  486.             `(jsr #'common-lisp::%checkNull)     ; signal error if extra argument
  487.             `(lea (a7 4) a7)                      ; cleanup stack
  488.         ]))
  489.  
  490. ;;
  491. ;;    compile-lambda-required-args
  492. ;;    Generates code to initialize required argumensts.
  493. ;;
  494. (defun compile-lambda-required-args ()
  495.     (dolist (sym (required-arguments *lambda-list*))
  496.         [
  497.             `(move.l (a2+) (-a7))            ; get argument
  498.             `(jsr #'common-lisp::%checkObj) ; signal error if argument missing
  499.             `(lea (a7 4) a7)                  ; cleanup stack
  500.             `(move.l d0 (a3 ,(* *arg-count* 4)))
  501.         ]
  502.         
  503.         (if (or (special-variable-p sym) (member sym *lambda-special-decs*))
  504.             (progn 
  505.                 (push sym *lambda-special-vars*)
  506.                 [
  507.                     `(move.l 0 (-a7))
  508.                     `(move.l (a3 ,(* *arg-count* 4)) (-a7))
  509.                     `(move.l ',sym (-a7))
  510.                     `(move.l a7 (-a7))
  511.                     `(jsr #'common-lisp::$push-special-bindings)
  512.                     `(lea (a7 16) a7)
  513.                 ]))
  514.  
  515.         (incf *arg-count*)))
  516.  
  517.  
  518. ;;
  519. ;;    compile-lambda-optional-args
  520. ;;    Generates code to initialize optional argumensts.
  521. ;;
  522. (defun compile-lambda-optional-args ()
  523.     (dolist (sym (optional-arguments *lambda-list*))
  524.         ;; initialize optional variable
  525.         (let ((else-label (gensym)) 
  526.                 (end-label (gensym)))
  527.             [
  528.                 `(tst.l (a2))                ;; is there an argument
  529.                 `(beq ,else-label)
  530.             ]
  531.             (if (and (consp sym) (>= (length sym) 3))
  532.                 (compile-form `(setq ,(caddr sym) t)))    ;; set supplied_p
  533.             [ 
  534.                 `(move.l (a2+) (a3 ,(* *arg-count* 4)))
  535.                 `(bra ,end-label)
  536.                 else-label
  537.             ]
  538.                 
  539.             ;; else do default initialization
  540.  
  541.             (if (and (consp sym) (>= (length sym) 3))
  542.                 (compile-form `(setq ,(caddr sym) nil)))    ;; set supplied_p
  543.  
  544.             (if (and (consp sym) (cdr sym))
  545.                 (progn
  546.                     [
  547.                         `(movem.l    a2 a3 d0 (-a7))
  548.                     ]
  549.                     (compile-form (cadr sym))
  550.                     [
  551.                         `(movem.l (a7+) a2 a3 d0)
  552.                         `(move.l d3 (a3 ,(* *arg-count* 4)))
  553.                     ])
  554.                 ;; else
  555.                 [
  556.                     `(move.l 'nil (a3 ,(* *arg-count* 4)))
  557.                 ])
  558.             [
  559.                 end-label
  560.             ])
  561.  
  562.         (if (or (special-variable-p sym) (member sym *lambda-special-decs*))
  563.             (progn 
  564.                 (push sym *lambda-special-vars*)
  565.                 [
  566.                     `(move.l 0 (-a7))
  567.                     `(move.l (a3 ,(* *arg-count* 4)) (-a7))
  568.                     `(move.l ',sym (-a7))
  569.                     `(move.l a7 (-a7))
  570.                     `(jsr #'common-lisp::$push-special-bindings)
  571.                     `(lea (a7 16) a7)
  572.                 ]))
  573.             
  574.         (incf *arg-count*)))
  575.  
  576.  
  577. ;;
  578. ;;    compile-lambda-rest-args
  579. ;;    Generates code to initialize rest arguments.
  580. ;;    We allow more than one.
  581. ;;
  582. (defun compile-lambda-rest-args ()
  583.     (let* ((rest-args (rest-arguments *lambda-list*)))
  584.         (if rest-args
  585.             [
  586.                 `(move.l a2 (-a7))
  587.                 `(jsr #'list)
  588.                 `(lea (a7 4) a7)
  589.             ])
  590.         (dolist (sym rest-args)
  591.             [
  592.                 `(move.l d0 (a3 ,(* *arg-count* 4)))
  593.             ]
  594.         
  595.         (if (or (special-variable-p sym) (member sym *lambda-special-decs*))
  596.                 (progn 
  597.                     (push sym *lambda-special-vars*)
  598.                     [
  599.                         `(move.l 0 (-a7))
  600.                         `(move.l (a3 ,(* *arg-count* 4)) (-a7))
  601.                         `(move.l ',sym (-a7))
  602.                         `(move.l a7 (-a7))
  603.                         `(jsr #'common-lisp::$push-special-bindings)
  604.                         `(lea (a7 16) a7)
  605.                     ]))
  606.  
  607.             (incf *arg-count*))))
  608.  
  609.  
  610. ;;
  611. ;;    compile-lambda-key-args
  612. ;;    Generates code to initialize key argumensts.
  613. ;;
  614. (defun compile-lambda-key-args ()
  615.     (dolist (n (key-arguments *lambda-list*))
  616.         (let* ((loop-label (gensym))
  617.                (exit-label (gensym))
  618.                (not-found-label (gensym))
  619.                lex-var 
  620.                default-init 
  621.                key-symbol)
  622.                         
  623.             (if (consp n)
  624.                 (setq lex-var (car n))
  625.                 (setq lex-var n))
  626.                             
  627.             (if (and (consp n) (cdr n))
  628.                 (setq default-init (cadr n))
  629.                 (setq default-init nil))                        
  630.                     
  631.             (setq key-symbol 
  632.                 (intern (symbol-name lex-var) (find-package :keyword)))
  633.                         
  634.             [
  635.                 `(move.l a2 a0)            ; a0 = current argument location
  636.                 `(move.l ',key-symbol d0)
  637.                 loop-label
  638.                 `(tst.l (a0))            ; make sure there are more arguments
  639.                 `(beq ,not-found-label)
  640.                 `(cmp.l (a0+) d0)
  641.                 `(bne ,loop-label)
  642.                 `(move.l (a0) (-a7))    ; make sure there is another argument
  643.                 `(jsr #'common-lisp::%checkObj)
  644.                 `(lea (a7 4) a7)          ; cleanup stack
  645.                 `(move.l d0 (a3 ,(* *arg-count* 4)))
  646.                 `(bra ,exit-label)
  647.                 not-found-label    
  648.             ]
  649.             (compile-form default-init)
  650.             [
  651.                 `(move.l d3 (a3 ,(* *arg-count* 4)))
  652.                 exit-label
  653.             ]
  654.  
  655.         (if (or (special-variable-p n) (member n *lambda-special-decs*))
  656.                 (progn 
  657.                     (push n *lambda-special-vars*)
  658.                     [
  659.                         `(move.l 0 (-a7))
  660.                         `(move.l (a3 ,(* *arg-count* 4)) (-a7))
  661.                         `(move.l ',n (-a7))
  662.                         `(move.l a7 (-a7))
  663.                         `(jsr #'common-lisp::$push-special-bindings)
  664.                         `(lea (a7 16) a7)
  665.                     ]))
  666.  
  667.             (incf *arg-count*))))
  668.  
  669.  
  670. ;;---------------------------------------------------
  671.  
  672. (defun compile-form (form)
  673.     (setq *last-call-was-values* nil)
  674.     (setq *last-call-was-tail-recursion* nil)
  675.     (cond 
  676.         ((null form) (compile-nil))
  677.         ((symbolp form) (compile-symbol form))
  678.         ((not (consp form))    (compile-literal-form form))
  679.         (t (compile-list-form form))))
  680.  
  681.  
  682. (defun compile-list-form (form)
  683.     (let ((firstobj (car form)))
  684.         (cond 
  685.             ((consp firstobj) (compile-explicit-lambda form))
  686.             ((not (symbolp firstobj))
  687.                 (error "Can't compile form--does not begin with a symbol"))
  688.             ((macro-function firstobj) (compile-form (macroexpand form)))
  689.             ((special-form-p firstobj) (compile-special-form form))
  690.             ((eq firstobj 'common-lisp::values) (compile-values-form form))
  691.             (t (compile-function-call-form form)))))
  692.  
  693.  
  694. (defun compile-special-form (form)
  695.     (case (car form)
  696.         (quote                     (compile-quote-form form)) 
  697.         (if                     (compile-if-form form))
  698.         (tagbody                 (compile-tagbody-form form))
  699.         (go                     (compile-go-tag form))
  700.         (setq                     (compile-setq-form form))
  701.         (block                     (compile-block-form form))
  702.         (return-from             (compile-return-from-form form))
  703.         (progn                     (compile-progn-form form))
  704.         (let                     (compile-let-form form))
  705.         (let*                     (compile-let*-form form))
  706.         (flet                     (compile-flet-form form))
  707.         (labels                 (compile-labels-form form))
  708.         (function                (compile-function-special-form form))
  709.         (catch                    (compile-catch-form form))
  710.         (throw                    (compile-throw-form form))
  711.         (unwind-protect         (compile-unwind-protect-form form))
  712.         (multiple-value-call     (compile-multiple-value-call-form form))
  713.         (eval-when                 (compile-eval-when-form form))
  714.         (declare                nil)
  715.         (otherwise                 (error "Special form not supported: ~A~%" (car form)))))
  716.  
  717.  
  718. (defun compile-explicit-lambda (form)
  719.     (if (not (eq 'lambda (caar form)))
  720.         (error "The first element of the expression: ~A is a list but it
  721.                 isn't a lambda expression~%" (car form)))
  722.     (compile-form `(funcall (function ,(car form)) ,@(cdr form))))
  723.  
  724. (defun compile-symbol (sym)
  725.     (let ((temp (find-lex sym)))        ; check for lexical variable
  726.         (if temp
  727.             (if (integerp (cdr temp))
  728.                 [
  729.                     `(move.l (a3 ,(* (cdr temp) 4)) d3)
  730.                 ]
  731.                 ;; else
  732.                 [
  733.                     `(move.l (a3 ,(* (cadr temp) 4)) a0)
  734.                     `($CDR a0 d3)
  735.                 ])
  736.         ;; else see if it is in the inherited environment
  737.             (if (member sym *environment*)
  738.                 [
  739.                     `(move.l 0 (-a7))
  740.                     `(move.l ',sym (-a7))
  741.                     `(move.l a4 (-a7))
  742.                     `(move.l a7 (-a7))
  743.                     `(jsr #'%environment-get-value)
  744.                     `(lea (a7 16) a7)
  745.                     `(move.l d0 d3)
  746.                 ]
  747.             ;; else assume special variable
  748.                 (compile-function-call-form `(symbol-value ',sym))))))
  749.                 
  750.  
  751. (defun compile-if-form (form)
  752.     (let ((else-label (gensym)) 
  753.           (end-label (gensym))
  754.           (test-form (cadr form))
  755.           (then-form (caddr form))
  756.           (else-form (cdddr form)))
  757.  
  758.         (compile-form test-form)
  759.         [
  760.             `(cmp.l 'nil d3)
  761.             `(beq ,else-label)
  762.         ]
  763.         (compile-form then-form)
  764.         (if (consp else-form)
  765.             [
  766.                 `(bra ,end-label)
  767.             ])
  768.         [
  769.             else-label
  770.         ]
  771.         (if (consp else-form)
  772.             (compile-form (car else-form)))
  773.         [
  774.             end-label
  775.         ]))
  776.  
  777.  
  778. (defun compile-tagbody-form (form)
  779.     (let ((tags nil))
  780.         ;; go through list once collecting tags
  781.         (dolist (n (cdr form))
  782.             (if (or (integerp n) (symbolp n))
  783.                 (push (cons n (gensym)) tags)))
  784.         
  785.         (push-cleanup (cons 'tagbody tags))
  786.  
  787.         (dolist (n (cdr form))
  788.             (if (or (integerp n) (symbolp n))
  789.                 (push (cdr (assoc n tags)) *asm*)
  790.                 ;; else it is a form to be evaluated
  791.                 (compile-form n)))
  792.  
  793.         (pop-cleanup)))
  794.             
  795. (defun compile-go-tag (form)
  796.     (let ((tag (cadr form)))
  797.         (if (not (or (integerp tag) (symbolp tag)))
  798.             (error "Invalid go tag encountered"))
  799.         (if (not (find-go-tag tag))            ;; if the tag is not already defined 
  800.             (error "Tag not defined in this scope"))
  801.  
  802.         ;; peel off cleanup stack
  803.         (let ((dest (find-go-tag-tagbody tag)))
  804.             (dolist (f *cleanup-forms-stack*)
  805.                 (if (eq f dest) (return))        ;; returns from the dolist block
  806.                 (case (car f)
  807.                     (unwind-protect  
  808.                         ;; include cleanup code
  809.                         (let ((cleanup-code (cdr f)))
  810.                             (dolist (n cleanup-code)
  811.                                 (push n *asm*))))
  812.                     (catch
  813.                         ;; remove dynamic catch tag
  814.                         [
  815.                             `(jsr #'common-lisp::%popCatcher)    ;; restore result
  816.                         ]))))
  817.                     
  818.         [
  819.             `(bra ,(cdr (find-go-tag tag)))
  820.         ])) 
  821.  
  822. (defun compile-setq-form (form)
  823.     (do ((f (cdr form) (cddr f)) var val temp)
  824.         ((endp f))
  825.         (setq var (car f))
  826.         (setq val (cadr f))
  827.         (setf temp (find-lex var))    ; check for lexical variable
  828.         (if temp
  829.             (progn
  830.                 (compile-form val)
  831.                 (if (integerp (cdr temp))
  832.                     [
  833.                         `(move.l d3 (a3 ,(* (cdr temp) 4)))
  834.                     ]
  835.                 ;; else
  836.                     [
  837.                         `(move.l (a3 ,(* (cadr temp) 4)) a0)
  838.                         `($SETCDR a0 d3)
  839.                     ]))
  840.         ;; else look in the inherited environment
  841.             (if (member var *environment*)
  842.                 (progn
  843.                     (compile-form val)
  844.                     [
  845.                         `(move.l 0 (-a7))
  846.                         `(move.l d3 (-a7))
  847.                         `(move.l ',var (-a7))
  848.                         `(move.l a4 (-a7))
  849.                         `(move.l a7 (-a7))
  850.                         `(jsr #'%environment-set-value)
  851.                         `(lea (a7 20) a7)
  852.                         `(move.l d0 d3)
  853.                     ])
  854.             ;; else call set function
  855.                 (compile-form `(set ',var ,val))))))
  856.  
  857.  
  858. (defun compile-quote-form (form)
  859.     (compile-literal-form (cadr form)))
  860.  
  861. (defun compile-block-form (form)
  862.     (let ((block-name (cadr form)) 
  863.           (block-forms (cddr form)) 
  864.           (exit-label (gensym)))
  865.         (push-cleanup (list 'block block-name exit-label))
  866.  
  867.         (dolist (f block-forms)
  868.             (compile-form f))
  869.  
  870.         [
  871.             exit-label
  872.         ]
  873.         (pop-cleanup)))
  874.  
  875. (defun compile-return-from-form (form)
  876.     (let ((block-name (cadr form))
  877.           (retval nil)
  878.           temp)
  879.         (if (consp (cddr form))
  880.             (setq retval (caddr form)))
  881.         (compile-form retval)
  882.         (if (null block-name)
  883.             (setq temp (find-any-block))
  884.             ;; else
  885.             (setq temp (find-block block-name)))
  886.         (unless temp (error "Block label not found"))
  887.  
  888.         ;; peel off cleanup stack
  889.         (let ((dest temp))
  890.             (dolist (f *cleanup-forms-stack*)
  891.                 (if (eq f dest) (return))        ;; returns from the dolist block
  892.                 (case (car f)
  893.                     (unwind-protect  
  894.                         ;; include cleanup code
  895.                         (let ((cleanup-code (cdr f)))
  896.                             (dolist (n cleanup-code)
  897.                                 (push n *asm*))))
  898.                     (catch
  899.                         ;; remove dynamic catch tag
  900.                         [
  901.                             `(jsr #'common-lisp::%popCatcher)    ;; restore result
  902.                         ]))))
  903.  
  904.         [    
  905.             `(bra ,(caddr temp))
  906.         ]))    
  907.  
  908. (defun compile-progn-form (form)
  909.     (let ((progn-forms (cdr form))) 
  910.         (dolist (f progn-forms)
  911.             (compile-form f))))
  912.  
  913. (defun compile-let-form (form)
  914.     (let* ((local-vars (cadr form)) 
  915.            (let-forms (cddr form)) 
  916.            (new-vars nil)
  917.            (special-vars nil)
  918.            (declarations nil)
  919.            (special-decs nil)
  920.            sym)
  921.  
  922.         ;; look for declarations
  923.         (do ((f let-forms (cdr f)))
  924.             ((null f) (setq let-forms f))
  925.             (if (and (consp (car f)) (eq (caar f) 'declare))
  926.                 (push (car f) declarations)
  927.                 (progn (setq let-forms f) (return))))
  928.  
  929.         ;; search declarations for special declarations
  930.         (dolist (declaration declarations)
  931.             (dolist (dec-form (cdr declaration))
  932.                 (if (and (consp dec-form) (eq (car dec-form) 'special))
  933.                     (setq special-decs (append (cdr dec-form) special-decs)))))
  934.                     
  935.         ;; go through variable list evaluating values and assigning to temporary
  936.         ;; space on the stack
  937.         (dolist (f local-vars)
  938.             (unless (or (consp f) (symbolp f)) 
  939.                 (error "Invalid 'let' variable"))
  940.             (if (or (symbolp f) (not (consp (cdr f))))
  941.                 [
  942.                     `(move.l 'nil (a3 ,(* *lex-counter* 4)))
  943.                 ]
  944.                 ;; else
  945.                 (progn
  946.                     (compile-form (cadr f))
  947.                     [
  948.                         `(move.l d3 (a3 ,(* *lex-counter* 4)))
  949.                     ]))
  950.  
  951.             ;; add the symbol to the list of new symbols
  952.             (if (consp f) 
  953.                 (setq sym (car f)) 
  954.                 (setq sym f)) 
  955.                 
  956.             (if (or (special-variable-p sym) (member sym special-decs))
  957.                 (progn 
  958.                     (if (null special-vars)     ;; if first one
  959.                         [
  960.                             `(move.l 0 (-a7))
  961.                         ])
  962.                     (push sym special-vars)
  963.                     [
  964.                         `(move.l (a3 ,(* *lex-counter* 4)) (-a7))
  965.                         `(move.l ',sym (-a7))
  966.                     ])
  967.                 ;; else
  968.                 (push (cons sym *lex-counter*) new-vars))
  969.  
  970.             (incf *lex-counter*))
  971.  
  972.         ;; add the new variables to the lexical environment
  973.         (add-lexical-variables new-vars)
  974.         (create-runtime-bindings)
  975.         
  976.         ;; if any special variables are present, add those bindings now
  977.         (if special-vars
  978.             (progn
  979.                 [
  980.                     `(move.l a7 (-a7))
  981.                     `(jsr #'common-lisp::$push-special-bindings)
  982.                     `(lea (a7 ,(* 8 (1+ (length special-vars)))) a7)
  983.                 ]
  984.                 (compile-unwind-protect-form 
  985.                     `(unwind-protect 
  986.                         (progn ,@let-forms)
  987.                         ($pop-special-bindings ',special-vars))))
  988.  
  989.             ;; else execute the forms directly
  990.             (dolist (f let-forms)
  991.                 (compile-form f)))
  992.         
  993.         ;; restore old lexical environment
  994.         (pop-cleanup)))
  995.  
  996. (defun compile-let*-form (form)
  997.     (let* ((local-vars (cadr form)) 
  998.            (let-forms (cddr form))
  999.            (special-vars nil)
  1000.            (declarations nil)
  1001.            (special-decs nil)
  1002.            sym
  1003.            (lex-var-count 0))
  1004.  
  1005.         ;; look for declarations
  1006.         (do ((f let-forms (cdr f)))
  1007.             ((null f) (setq let-forms f))
  1008.             (if (and (consp (car f)) (eq (caar f) 'declare))
  1009.                 (push (car f) declarations)
  1010.                 (progn (setq let-forms f) (return))))
  1011.  
  1012.         ;; search declarations for special declarations
  1013.         (dolist (declaration declarations)
  1014.             (dolist (dec-form (cdr declaration))
  1015.                 (if (and (consp dec-form) (eq (car dec-form) 'special))
  1016.                     (setq special-decs (append (cdr dec-form) special-decs)))))
  1017.  
  1018.         ;; go through variable list evaluating values and assigning to temporary
  1019.         ;; space on the stack
  1020.         (dolist (f local-vars)
  1021.             (unless (or (consp f) (symbolp f)) 
  1022.                 (error "Invalid 'let' variable: ~A~%" f))
  1023.             (if (or (symbolp f) (not (consp (cdr f))))
  1024.                 [
  1025.                     `(move.l 'nil (a3 ,(* *lex-counter* 4)))
  1026.                 ]
  1027.                 ;; else
  1028.                 (progn
  1029.                     (compile-form (cadr f))
  1030.                     [
  1031.                         `(move.l d3 (a3 ,(* *lex-counter* 4)))
  1032.                     ]))
  1033.  
  1034.             ;; add the symbol to the list of new symbols
  1035.             (if (consp f) 
  1036.                 (setq sym (car f)) 
  1037.                 (setq sym f)) 
  1038.     
  1039.             (if (or (special-variable-p sym) (member sym special-decs))
  1040.                 (progn 
  1041.                     (push sym special-vars)
  1042.                     [
  1043.                         `(move.l 0 (-a7))
  1044.                         `(move.l (a3 ,(* *lex-counter* 4)) (-a7))
  1045.                         `(move.l ',sym (-a7))
  1046.                         `(move.l a7 (-a7))
  1047.                         `(jsr #'common-lisp::$push-special-bindings)
  1048.                         `(lea (a7 16) a7)
  1049.                     ])
  1050.                 ;; else
  1051.                 (progn
  1052.                     (add-lexical-variables (list (cons sym *lex-counter*)))
  1053.                     (incf lex-var-count)))
  1054.  
  1055.             (incf *lex-counter*))
  1056.  
  1057.         (create-runtime-bindings)    
  1058.         
  1059.         ;; if any special variables are present, add those bindings now
  1060.         (if special-vars
  1061.             (compile-unwind-protect-form 
  1062.                 `(unwind-protect 
  1063.                     (progn ,@let-forms)
  1064.                     ($pop-special-bindings ',special-vars)))
  1065.  
  1066.             ;; else execute the forms directly
  1067.             (dolist (f let-forms)
  1068.                 (compile-form f)))
  1069.         
  1070.         ;; restore old lexical environment
  1071.         (dotimes (i lex-var-count)
  1072.             (pop-cleanup))))
  1073.  
  1074. (defun compile-flet-form (form)
  1075.     (let* ((local-funs (cadr form)) 
  1076.            (flet-forms (cddr form)) 
  1077.            (new-funs nil)
  1078.            (declarations nil))
  1079.  
  1080.         ;; look for declarations
  1081.         (do ((f flet-forms (cdr f)))
  1082.             ((null f) (setq flet-forms f))
  1083.             (if (and (consp (car f)) (eq (caar f) 'declare))
  1084.                 (push (car f) declarations)
  1085.                 (progn (setq flet-forms f) (return))))
  1086.  
  1087.         ;; search declarations for special declarations
  1088. #|
  1089.         ;; do we need to deal with special declarations here?  RGC
  1090.         (dolist (declaration declarations)
  1091.             (dolist (dec-form (cdr declaration))
  1092.                 (if (and (consp dec-form) (eq (car dec-form) 'special))
  1093.                     (setq special-decs (append (cdr dec-form) special-decs)))))
  1094. |#                    
  1095.         ;; go through function list evaluating values and assigning to temporary
  1096.         ;; space on the stack
  1097.         (dolist (f local-funs)
  1098.             (unless (and (consp f) (consp (cdr f)))
  1099.                 (error "Invalid 'flet' function expression"))
  1100.             (let* ((func-name (car f))
  1101.                    (func-args (cadr f))
  1102.                    (func-forms (cddr f)))
  1103.                 (compile-function-special-form 
  1104.                     `(function (lambda ,func-args (block ,func-name ,@func-forms))))
  1105.                 [
  1106.                     `(move.l d3 (a3 ,(* *lex-counter* 4)))
  1107.                 ]
  1108.  
  1109.                 ;; add the function name to the list of new functions
  1110.                 (push (cons func-name *lex-counter*) new-funs)                
  1111.                 (incf *lex-counter*)))
  1112.  
  1113.         ;; add the new functions to the lexical environment
  1114.         (add-lexical-functions new-funs)
  1115.         (create-runtime-bindings)
  1116.         
  1117.         ;; execute the forms directly
  1118.         (dolist (f flet-forms)
  1119.             (compile-form f))
  1120.         
  1121.         ;; restore old lexical environment
  1122.         (pop-cleanup)))
  1123.  
  1124. (defun compile-labels-form (form)
  1125.     (let* ((local-funs (cadr form)) 
  1126.            (flet-forms (cddr form)) 
  1127.            (new-funs nil)
  1128.            (declarations nil))
  1129.  
  1130.         ;; look for declarations
  1131.         (do ((f flet-forms (cdr f)))
  1132.             ((null f) (setq flet-forms f))
  1133.             (if (and (consp (car f)) (eq (caar f) 'declare))
  1134.                 (push (car f) declarations)
  1135.                 (progn (setq flet-forms f) (return))))
  1136.  
  1137.         ;; search declarations for special declarations
  1138. #|
  1139.         ;; do we need to deal with special declarations here?  RGC
  1140.         (dolist (declaration declarations)
  1141.             (dolist (dec-form (cdr declaration))
  1142.                 (if (and (consp dec-form) (eq (car dec-form) 'special))
  1143.                     (setq special-decs (append (cdr dec-form) special-decs)))))
  1144. |#                    
  1145.         (let ((counter *lex-counter*))
  1146.             (dolist (f local-funs)
  1147.                 (unless (and (consp f) (consp (cdr f)))
  1148.                     (error "Invalid 'labels' function expression"))
  1149.                 (let* ((func-name (car f)))
  1150.                     (push (cons func-name counter) new-funs)                
  1151.                     (incf counter))))
  1152.  
  1153.         ;; add the new functions to the lexical environment
  1154.         (add-lexical-functions new-funs)
  1155.         (create-runtime-bindings)
  1156.         
  1157.         ;; go through function list evaluating values and assigning to temporary
  1158.         ;; space on the stack
  1159.         (dolist (f local-funs)
  1160.             (let* ((func-name (car f))
  1161.                    (func-args (cadr f))
  1162.                    (func-forms (cddr f)))
  1163.                 (compile-function-special-form 
  1164.                     `(function (lambda ,func-args (block ,func-name ,@func-forms))))
  1165.                 [
  1166.                     `(move.l d3 (a3 ,(* *lex-counter* 4)))
  1167.                 ]
  1168.                 (incf *lex-counter*)))
  1169.  
  1170.         ;; execute the forms directly
  1171.         (dolist (f flet-forms)
  1172.             (compile-form f))
  1173.         
  1174.         ;; restore old lexical environment
  1175.         (pop-cleanup)))
  1176.  
  1177. (defun compile-function-special-form (form)
  1178.     (let ((func-form (cadr form)))
  1179.         
  1180.         ;; I don't think this will occur, but just in case, we can't
  1181.         ;; keep a reference to an anonymous function object.
  1182.         (if (functionp func-form)
  1183.             (error "Can't compile expression with anonymous function: ~A~%" form))
  1184.  
  1185.         ;; if a compiled lambda expression
  1186.         (if (and (consp func-form) (eq (car func-form) 'lambda))
  1187.             (let ((name nil)
  1188.                   (first-form (third func-form)))
  1189.                 (if (and (consp first-form) (eq (first first-form) 'block))
  1190.                     (setq name (second (third func-form))))
  1191.  
  1192.                 ;; create a new compiled function
  1193.                 (setq func-form (compile-lambda func-form name))     
  1194.                 [
  1195.                     `(move.l 0 (-a7))
  1196.                     `(move.l ',func-form (-a7))
  1197.                     `(move.l a7 (-a7))
  1198.                     `(jsr #'%copy-compiled-function)
  1199.                     `(lea (a7 12) a7)
  1200.                     `(move.l d0 d3)
  1201.                 ]
  1202.                 (export-environment)
  1203.                 (return)))
  1204.                 
  1205.         (unless (symbolp func-form)
  1206.             (error "function special form: ~%Expected a symbol: ~A~%" func-form))
  1207.  
  1208.         (let ((temp (find-lex-function func-form)))    ; check for lexical function
  1209.             (if temp
  1210.                 (if (integerp (cdr temp))
  1211.                     [
  1212.                         `(move.l (a3 ,(* (cdr temp) 4)) d3)
  1213.                     ]
  1214.                     ;; else
  1215.                     [
  1216.                         `(move.l (a3 ,(* (cadr temp) 4)) a0)
  1217.                         `($CDR a0 d3)
  1218.                     ])
  1219.                 ;; else see if it is in the inherited environment
  1220.                 (if (member func-form *environment*)
  1221.                     (progn
  1222.                         [
  1223.                             `(move.l 0 (-a7))
  1224.                             `(move.l ',func-form (-a7))
  1225.                             `(move.l a4 (-a7))
  1226.                             `(move.l a7 (-a7))
  1227.                             `(jsr #'%environment-get-function)
  1228.                             `(lea (a7 16) a7)
  1229.                             `(move.l d0 d3)
  1230.                         ])
  1231.                         
  1232.                 ;; else assume global function
  1233.                     (compile-function-call-form `(symbol-function ',func-form)))))))
  1234.  
  1235.  
  1236. (defun compile-catch-form (form)
  1237.     (let ((catch-tag (cadr form)) 
  1238.           (catch-forms (cddr form)) 
  1239.           (exit-label (gensym)))
  1240.  
  1241.         (push-cleanup (list 'CATCH catch-tag))
  1242.         
  1243.         ;; evaluate the tag
  1244.         (compile-form catch-tag)
  1245.         
  1246.         ;; make room for jmp-buf on stack (12 * 4 bytes)
  1247.         [
  1248.             `(lea (a7 -48) a7)
  1249.  
  1250.         ;; pushCatcher(tag, jmp_buf)
  1251.             `(move.l a7 (-a7))            ;; push jmp_buf
  1252.             `(move.l d3 (-a7))            ;; push tag
  1253.             `(jsr #'common-lisp::%pushCatcher)
  1254.             `(lea (a7 8) a7)            ;; cleanup stack
  1255.  
  1256.         ;; setjmp(jmp_buf)
  1257.             `(move.l a7 (-a7))            ;; push jmp_buf
  1258.             `(jsr #'common-lisp::%setjmp)
  1259.             `(lea (a7 4) a7)
  1260.         
  1261.         ;; if d0 != 0, we caught an exception
  1262.             `(move.l d0 d3)
  1263.             `(tst.l d0)
  1264.             `(bne ,exit-label) 
  1265.             `(move.l 'nil d3)
  1266.         ]
  1267.         
  1268.         (dolist (f catch-forms)
  1269.             (compile-form f))
  1270.  
  1271.         [
  1272.             exit-label
  1273.         ]
  1274.         
  1275.         (pop-cleanup)
  1276.         
  1277.         ;; popCatcher()
  1278.         [
  1279.             `(lea (a7 48) a7)        ;; cleanup jmp_buf
  1280.             `(jsr #'common-lisp::%popCatcher)
  1281.         ]))
  1282.         
  1283. (defun compile-throw-form (form)
  1284.     (let ((throw-tag (cadr form)) 
  1285.           (throw-form (caddr form))) 
  1286.  
  1287.         ;; evaluate the form
  1288.         (compile-form throw-form)
  1289.         [
  1290.             `(move.l d3 (-a7))
  1291.         ]
  1292.         
  1293.         ;; evaluate the tag
  1294.         (compile-form throw-tag)
  1295.         [
  1296.             `(move.l d3 (-a7))            
  1297.             `(jsr #'%throwException)    ;; call throw handler
  1298.         ]))
  1299.  
  1300. (defun compile-unwind-protect-form (form)
  1301.     (let ((protected-form (cadr form))
  1302.           (cleanup-forms (cddr form)) 
  1303.           (label1 (gensym))
  1304.           (label2 (gensym)))
  1305.         
  1306.         ;; make room for jmp-buf on stack (12 * 4 bytes)
  1307.         [
  1308.             `(lea (a7 -48) a7)
  1309.  
  1310.             ;; pushCatcher(tag, jmp_buf)
  1311.             `(move.l a7 (-a7))                ;; push jmp_buf
  1312.             `(moveq 0 d0)
  1313.             `(move.l d0 (-a7))                ;; push tag
  1314.             `(jsr #'common-lisp::%pushCatcher)
  1315.             `(lea (a7 8) a7)                ;; cleanup stack
  1316.  
  1317.             ;; setjmp(jmp_buf)
  1318.             `(move.l a7 (-a7))                ;; push jmp_buf
  1319.             `(jsr #'common-lisp::%setjmp)
  1320.             `(lea (a7 4) a7)
  1321.         
  1322.             ;; if d0 != 0, we caught an exception
  1323.             `(move.l d0 d3)
  1324.             `(move.l d0 (-a7))                ;; save result on stack
  1325.             `(tst.l d0)
  1326.             `(bne ,label1)
  1327.         ]
  1328.         
  1329.         ;; generate code for cleanup forms
  1330.         (let ((*asm* nil))
  1331.             [
  1332.                 `(move.l d3 (-a7))            ;; store result
  1333.                 `(move.l common-lisp::%multiple-values-address a0)
  1334.                 `(move.l (a0) (-a7))
  1335.                 `(jsr #'common-lisp::%popCatcher)
  1336.             ]
  1337.             (dolist (f cleanup-forms)
  1338.                 (compile-form f))
  1339.             [
  1340.                 `(move.l common-lisp::%multiple-values-address a0)
  1341.                 `(move.l (a7+) (a0))
  1342.                 `(move.l (a7+) d3)            ;; retrieve result
  1343.             ]
  1344.             (setq *asm* (nreverse *asm*))
  1345.             (push-cleanup (cons 'UNWIND-PROTECT *asm*))) 
  1346.         
  1347.         ;; compile protected form
  1348.         (compile-form protected-form)
  1349.  
  1350.         [
  1351.             label1
  1352.         ]
  1353.         
  1354.         ;; include cleanup code
  1355.         (let ((cleanup-code (cdr (pop-cleanup))))
  1356.             (dolist (n cleanup-code)
  1357.                 (push n *asm*)))
  1358.                 
  1359.         ;; retrieve exception result
  1360.         [
  1361.             `(move.l (a7+) a0)
  1362.             `(tst.l a0)
  1363.             `(beq ,label2)
  1364.  
  1365.             ;; continue thrown exception
  1366.             `(move.l a0 (-a7))
  1367.             `(jsr #'common-lisp::%continueException)
  1368.             label2
  1369.             `(lea (a7 48) a7)        ;; cleanup jmp_buf
  1370.         ]))
  1371.  
  1372. ;; for non toplevel eval-when forms
  1373. (defun compile-eval-when-form (form)
  1374.     (if (or (not (consp form)) (< (length form) 2) (not (listp (cadr form))))
  1375.         (error "'eval-when' form missing condition list."))
  1376.  
  1377.     (let* ((conditions (cadr form)))
  1378.         (if (or (member 'common-lisp::eval conditions) 
  1379.                 (member :execute conditions))
  1380.             (compile-progn-form (cons 'common-lisp::progn (cddr form)))
  1381.             (compile-nil))))    
  1382.  
  1383. (defun compile-multiple-value-call-form (form)
  1384.     (let* ((func (cadr form))
  1385.            (forms (cddr form))
  1386.            (numforms (length forms))
  1387.            (stackframe (* 4 (1+ numforms)))
  1388.            (counter 0)
  1389.            temp)
  1390.         (compile-form func)
  1391.         [
  1392.             `(move.l d3 (-a7))                ; push function address on stack
  1393.             `(lea (a7 ,(- stackframe)) a7)
  1394.         ]
  1395.         (dolist (p forms)                    ; execute each form
  1396.             (compile-form p)
  1397.             [
  1398.                 `($IFELSE 
  1399.                     (
  1400.                         (tst.l (common-lisp::%multiple-values-address))
  1401.                     )
  1402.                     (
  1403.                         ;; if no multiple values, just list the single value
  1404.                         (move.l 0 (-a7))
  1405.                         (move.l 'nil (-a7))
  1406.                         (move.l d3 (-a7))
  1407.                         (move.l a7 (-a7))
  1408.                         (jsr #'cons)
  1409.                         (lea (a7 16) a7)
  1410.                         (move.l d0 d3)
  1411.                     )
  1412.                     (
  1413.                         ;; otherwise get the list of values
  1414.                         (move.l (common-lisp::%multiple-values-address) d3)
  1415.                     ))    
  1416.                         
  1417.                 `(move.l d3 (a7 ,(* counter 4)))
  1418.             ]
  1419.             (incf counter))
  1420.         
  1421.         ;; concatenate all the lists together and store in d3
  1422.         [
  1423.             `(clr.l (a7 ,(* counter 4)))
  1424.             `(move.l a7 (-a7))            ; pass address of params to function
  1425.             `(jsr #'append)
  1426.             `(move.l d0 d3)
  1427.             `(lea (a7 ,(+ 4 stackframe)) a7)            
  1428.         ]
  1429.  
  1430.         ;; now apply the passed function to the resulting value list
  1431.         [
  1432.             `(move.l (a7+) a0)            ; a0 = function address
  1433.             `(move.l 0 (-a7))
  1434.             `(move.l d3 (-a7))            ; argument list
  1435.             `(move.l a0 (-a7))            ; function
  1436.             `(move.l a7 (-a7))            ; pass address of params to function
  1437.             `(jsr #'apply)
  1438.             `(move.l d0 d3)
  1439.             `(lea (a7 16) a7)            
  1440.         ]))
  1441.  
  1442. (defun compile-values-form (form)
  1443.     (compile-function-call-form form)
  1444.     (setq *last-call-was-values* t))
  1445.     
  1446. (defun compile-function-call-form (form)
  1447.  
  1448. #|
  1449.     ;; print warning message if function hasn't been defined yet
  1450.     (if (not (functionp (symbol-function (car form))))
  1451.         (format t "Warning: function ~A missing definition~%" (car form)))
  1452. |#
  1453.     (if (or (find-lex-function (car form)) (member (car form) *environment*))
  1454.         (progn
  1455.             (compile-function-call-form `(funcall (function ,(car form)) ,@(cdr form)))
  1456.             (return)))
  1457.  
  1458.     (let* ((numparams (1- (length form)))
  1459.            (stackframe (* 4 (1+ numparams)))
  1460.            (func (car form))
  1461.            (funcparams (cdr form))
  1462.            (counter 0)
  1463.            (tail-recursive (if (eq func *function-name*) *asm*))
  1464.            temp)
  1465.         [
  1466.             `(lea (a7 ,(- stackframe)) a7)
  1467.         ]
  1468.         (dolist (p funcparams)                ; get parameters for function call
  1469.             (setf temp (find-lex p))        ; check for lexical variable
  1470.             (if temp
  1471.                 (if (integerp (cdr temp))
  1472.                     [
  1473.                         `(move.l (a3 ,(* (cdr temp) 4)) (a7 ,(* counter 4)))
  1474.                     ]
  1475.                     ;; else
  1476.                     [
  1477.                         `(move.l (a3 ,(* (cadr temp) 4)) a0)
  1478.                         `($CDR a0 (a7 ,(* counter 4)))
  1479.                     ])
  1480.                 ;; else
  1481.                 (progn 
  1482.                     (compile-form p)    ; ignore multiple values in params
  1483.                     [
  1484.                         `(move.l d3 (a7 ,(* counter 4)))
  1485.                     ]))
  1486.             (incf counter))
  1487.         
  1488.         ;; clear the last position to zero
  1489.         [
  1490.             `(clr.l (a7 ,(* counter 4)))
  1491.             `(move.l a7 (-a7))                ; pass address of params to function
  1492.         ]
  1493.         
  1494.         ;; if it is a recursive call to this function, we need to handle it specially
  1495.         (if (eq func *function-name*)
  1496.             [
  1497.                 `(bsr ,*function-entry-label*)
  1498.             ]
  1499.         ;; else
  1500.             (progn
  1501.                 [
  1502.                     `(jsr #',func)
  1503.                 ]))
  1504.         
  1505.         [
  1506.             `(move.l d0 d3)    
  1507.             `(lea (a7 ,(+ 4 stackframe)) a7)     ;; clean up stack
  1508.         ]
  1509.  
  1510.         ;; flag tail recursion
  1511.         (setq *last-call-was-tail-recursion* tail-recursive)))
  1512.  
  1513. (defun compile-integer (form)
  1514.     (if (typep form 'bignum)
  1515.         (compile-bignum form)
  1516.         [
  1517.             `(move.l ,form (-a7))
  1518.             `(jsr #'common-lisp::%integerAtom)
  1519.             `(lea (a7 4) a7)
  1520.             `(move.l d0 d3)
  1521.         ]))
  1522.  
  1523. (defun compile-bignum (num)
  1524.   (let* ((numcells (cl::%bignum-cells num))
  1525.          (length-flag (if (minusp num) (- numcells) numcells)))
  1526.  
  1527.     ;; allocate room for the data
  1528.     [
  1529.         `(lea (a7 ,(- (* (1+ numcells) 4))) a7)
  1530.         `(move.l a7 a0)
  1531.         `(move.l ,length-flag (a0+))
  1532.     ]
  1533.     (dotimes (i numcells)
  1534.         [
  1535.             `(move.l ,(cl::%bignum-cell num i) (a0+))
  1536.         ])
  1537.         
  1538.     ;; now push the address of this data on the stack and create a bignum
  1539.     [
  1540.         `(move.l a7 (-a7))
  1541.         `(jsr #'cl::%bignumAtomFromLongs)
  1542.         `(lea (a7 ,(+ 8 (* 4 numcells))) a7)
  1543.         `(move.l d0 d3)
  1544.     ]))
  1545.  
  1546. (defun string-int-with-pad (string index)
  1547.     (if (>= index (length string))
  1548.         0
  1549.         (char-int (elt string index))))
  1550.     
  1551. (defun compile-string (string)
  1552.   (let* ((numchars (+ 1 (length string)))
  1553.           n
  1554.           temp
  1555.           (num-longs (truncate (+ 3 numchars) 4)))
  1556.  
  1557.     ;; allocate room for the string
  1558.     [
  1559.         `(lea (a7 ,(- (* num-longs 4))) a7)
  1560.         `(move.l a7 a0)
  1561.     ]
  1562.     (dotimes (i num-longs)
  1563.         (setq temp (* i 4))
  1564.  
  1565.         ;; gather four characters into a long
  1566.         (setq n
  1567.             (+
  1568.                 (* (string-int-with-pad string temp) #x1000000)
  1569.                 (* (string-int-with-pad string (+ temp 1)) #x10000)
  1570.                 (* (string-int-with-pad string (+ temp 2)) #x100)
  1571.                 (string-int-with-pad string (+ temp 3))))
  1572.         [
  1573.             `(move.l ,n (a0+))
  1574.         ])
  1575.         
  1576.     ;; now push the address of this string on the stack and create a string
  1577.     [
  1578.         `(move.l a7 (-a7))
  1579.         `(jsr #'common-lisp::%stringAtom)
  1580.         `(lea (a7 ,(+ 4 (* 4 num-longs))) a7)
  1581.         `(move.l d0 d3)
  1582.     ]))
  1583.  
  1584.  
  1585. ;; need to add support for bit-vectors
  1586. (defun compile-literal-form (form)
  1587.     (cond
  1588.         ((symbolp form)        [ `(move.l ',form d3) ])            
  1589.         ((integerp form)     (compile-integer form))
  1590.         ((stringp form)        (compile-string form))
  1591.         ((characterp form)     (compile-character form))
  1592.         ((listp form)         (compile-quoted-list form))
  1593.         ((vectorp form)        (compile-vector form))
  1594.         ((floatp form)        (compile-float form))
  1595.         ((typep form 'ratio)(compile-ratio form))
  1596.         ((typep form 'complex)(compile-complex form))
  1597.         
  1598.         ;; we will have to code a direct reference to the object
  1599.         ;; This won't work if we use 'compile-file'.
  1600.         (t [ `(move.l ',form d3) ])))
  1601.             
  1602. (defun compile-character (form)
  1603.     [
  1604.         `(move.l ,(char-int form) (-a7))
  1605.         `(jsr #'common-lisp::%charAtom)
  1606.         `(lea (a7 4) a7)
  1607.         `(move.l d0 d3)
  1608.     ])
  1609.     
  1610. ;;
  1611. ;;    compile-quoted-list()
  1612. ;;    We catch and save the last form in case we are dealing with
  1613. ;;    a dotted list or dot pair.
  1614. ;;
  1615. (defun compile-quoted-list (form &aux (last-element (cdr (last form))))
  1616.     (setq form (reverse form))
  1617.     (let ((list-length (length form)))
  1618.         [
  1619.             `(move.l 0 (-a7))
  1620.         ]
  1621.         (compile-literal-form last-element)
  1622.         [
  1623.             `(move.l d3 (-a7))
  1624.         ]
  1625.         (dolist (f form)
  1626.             (compile-literal-form f)
  1627.             [
  1628.                 `(move.l d3 (-a7))
  1629.             ])
  1630.         [
  1631.             `(move.l a7 (-a7))
  1632.             `(jsr #'list*)
  1633.             `(lea (a7 ,(+ 12 (* list-length 4))) a7)
  1634.             `(move.l d0 d3)
  1635.         ]))
  1636.  
  1637. ;;
  1638. ;;    compile-vector()
  1639. ;;
  1640. (defun compile-vector (form)
  1641.     (setq form (nreverse (concatenate 'list form)))
  1642.     (let ((list-length (length form)))
  1643.         [
  1644.             `(move.l 0 (-a7))
  1645.         ]
  1646.         (dolist (f form)
  1647.             (compile-literal-form f)
  1648.             [
  1649.                 `(move.l d3 (-a7))
  1650.             ])
  1651.         [
  1652.             `(move.l a7 (-a7))
  1653.             `(jsr #'vector)
  1654.             `(lea (a7 ,(+ 8 (* list-length 4))) a7)
  1655.             `(move.l d0 d3)
  1656.         ]))
  1657.  
  1658. ;; define these in order to get at the binary representation of a floating
  1659. ;; point number so that we can generate the machine code to build it.
  1660. ;; These functions don't check their type, so we get get the data.
  1661.  
  1662. (defasm car_ (x)
  1663. #{
  1664.     ($FUNC-BEGIN 0)
  1665.     (move.l (a0) a0)
  1666.     ($CAR a0)
  1667.     (move.l a0 (-a7))
  1668.     (jsr #'common-lisp::%integerAtom)
  1669.     (lea (a7 4) a7)
  1670.     ($RETURN d0)
  1671. })
  1672.  
  1673. (defasm cdr_ (x)
  1674. #{
  1675.     ($FUNC-BEGIN 0)
  1676.     (move.l (a0) a0)
  1677.     ($CDR a0)
  1678.     (move.l a0 (-a7))
  1679.     (jsr #'common-lisp::%integerAtom)
  1680.     (lea (a7 4) a7)
  1681.     ($RETURN d0)
  1682. })
  1683.  
  1684. ;;
  1685. ;;    compile-float()
  1686. ;;
  1687. (defun compile-float (form)
  1688.     [
  1689.         `(move.l ,(cdr_ form) (-a7))
  1690.         `(move.l ,(car_ form) (-a7))
  1691.         `(jsr #'common-lisp::%floatAtomFromLongs)
  1692.         `(lea (a7 8) a7)
  1693.         `(move.l d0 d3)
  1694.     ])
  1695.  
  1696. ;;
  1697. ;;    compile-ratio()
  1698. ;;
  1699. (defun compile-ratio (form)
  1700.     [
  1701.         `(move.l 0 (-a7))
  1702.     ]
  1703.     (compile-form (denominator form))
  1704.     [
  1705.         `(move.l d3 (-a7))
  1706.     ]    
  1707.     (compile-form (numerator form))
  1708.     [
  1709.         `(move.l d3 (-a7))
  1710.         `(move.l a7 (-a7))
  1711.         `(jsr #'/)
  1712.         `(lea (a7 16) a7)
  1713.         `(move.l d0 d3)
  1714.     ])
  1715.     
  1716. ;;
  1717. ;;    compile-complex()
  1718. ;;
  1719. (defun compile-complex (form)
  1720.     [
  1721.         `(move.l 0 (-a7))
  1722.     ]
  1723.     (compile-form (imagpart form))
  1724.     [
  1725.         `(move.l d3 (-a7))
  1726.     ]    
  1727.     (compile-form (realpart form))
  1728.     [
  1729.         `(move.l d3 (-a7))
  1730.         `(move.l a7 (-a7))
  1731.         `(jsr #'complex)
  1732.         `(lea (a7 16) a7)
  1733.         `(move.l d0 d3)
  1734.     ])
  1735.     
  1736.  
  1737. (defun check-lambda (lambda)
  1738.     (let ((lambda-list (cadr lambda)))
  1739.         (dolist (n lambda-list)
  1740.             (if (member n *unsupported-lambda-list-keywords*)
  1741.                 (error "Can't compile this lambda list keyword: ~A~%" n)))))
  1742.             
  1743.     
  1744. (defun find-lex (var)
  1745.     (let (found)
  1746.         (dolist (n *cleanup-forms-stack* nil)
  1747.             (if (eq (car n) 'LET)
  1748.                 (progn
  1749.                     (setq found (assoc var (cdr n)))
  1750.                     (if found (return-from find-lex found)))))))
  1751.  
  1752. (defun find-lex-function (var)
  1753.     (let (found)
  1754.         (dolist (n *cleanup-forms-stack* nil)
  1755.             (if (eq (car n) 'FLET)
  1756.                 (progn
  1757.                     (setq found (assoc var (cdr n)))
  1758.                     (if found (return-from find-lex-function found)))))))
  1759.  
  1760. (defun find-go-tag (var)
  1761.     (let (found)
  1762.         (dolist (n *cleanup-forms-stack* nil)
  1763.             (if (eq (car n) 'TAGBODY)
  1764.                 (progn
  1765.                     (setq found (assoc var (cdr n)))
  1766.                     (if found (return-from find-go-tag found)))))))
  1767.  
  1768. ;;
  1769. ;;    find-go-tag-tagbody
  1770. ;;    Returns the cleanup form for the TAGBODY block which contains the 
  1771. ;;    passed tag.
  1772. ;;
  1773. (defun find-go-tag-tagbody (var)
  1774.     (let (found)
  1775.         (dolist (n *cleanup-forms-stack* nil)
  1776.             (if (eq (car n) 'TAGBODY)
  1777.                 (progn
  1778.                     (setq found (assoc var (cdr n)))
  1779.                     (if found (return-from find-go-tag-tagbody n)))))))
  1780.  
  1781. (defun find-block (name)
  1782.     (dolist (n *cleanup-forms-stack* nil)
  1783.         (if (eq (car n) 'BLOCK)
  1784.             (if (eq (cadr n) name)
  1785.                 (return-from find-block n)))))
  1786.  
  1787. (defun find-any-block ()
  1788.     (dolist (n *cleanup-forms-stack* nil)
  1789.         (if (eq (car n) 'BLOCK)
  1790.             (return-from find-any-block n))))
  1791.  
  1792. ;;
  1793. ;;    required-arguments
  1794. ;;    Returns a list of the required arguments in a lambda list.
  1795. ;;
  1796. (defun required-arguments (lambda-list)
  1797.     (let ((arglist nil))
  1798.         (dolist (n lambda-list)
  1799.             (if (member n *lambda-list-keywords*)
  1800.                 (return)        ;; exit dolist loop
  1801.                 (push n arglist)))
  1802.         (nreverse arglist)))
  1803.  
  1804. ;;
  1805. ;;    optional-arguments
  1806. ;;    Returns a list of the optional arguments in a lambda list.
  1807. ;;
  1808. (defun optional-arguments (lambda-list)
  1809.     (let ((arglist nil))
  1810.         (dolist (n (cdr (member '&optional lambda-list)))
  1811.             (if (member n *lambda-list-keywords*)
  1812.                 (return)        ;; exit dolist loop
  1813.                 (push n arglist)))
  1814.         (nreverse arglist)))
  1815.  
  1816. ;; we don't need this
  1817. ;;
  1818. ;;(defun get-supplied-p-args (lambda-list)    
  1819. ;;    (let ((args nil) (forms (optional-arguments lambda-list)))
  1820. ;;        (dolist (f forms)
  1821. ;;            (if (>= (length f) 3)
  1822. ;;                (push (list (caddr f) nil) args)))
  1823. ;;        (reverse args)))                
  1824.  
  1825. ;;
  1826. ;;    rest-arguments
  1827. ;;    Returns a list of the rest arguments in a lambda list.
  1828. ;;
  1829. (defun rest-arguments (lambda-list)
  1830.     (let ((arglist nil))
  1831.         (dolist (n (cdr (member '&rest lambda-list)))
  1832.             (if (member n *lambda-list-keywords*)
  1833.                 (return)        ;; exit dolist loop
  1834.                 (push n arglist)))
  1835.         (nreverse arglist)))
  1836.         
  1837. ;;
  1838. ;;    key-arguments
  1839. ;;    Returns a list of the optional key in a lambda list.
  1840. ;;
  1841. (defun key-arguments (lambda-list)
  1842.     (let ((arglist nil))
  1843.         (dolist (n (cdr (member '&key lambda-list)))
  1844.             (if (member n *lambda-list-keywords*)
  1845.                 (return)        ;; exit dolist loop
  1846.                 (push n arglist)))
  1847.         (nreverse arglist)))
  1848.         
  1849. ;;
  1850. ;;    aux-arguments
  1851. ;;    Returns a list of the aux arguments in a lambda list.
  1852. ;;
  1853. (defun aux-arguments (lambda-list)
  1854.     (let ((arglist nil))
  1855.         (dolist (n (cdr (member '&aux lambda-list)))
  1856.             (if (member n *lambda-list-keywords*)
  1857.                 (return)        ;; exit dolist loop
  1858.                 (push n arglist)))
  1859.         (nreverse arglist)))
  1860.         
  1861.  
  1862. ;;
  1863. ;;    kill-multiple-values
  1864. ;;    Use this function to make sure that ignored multiple values don't stick
  1865. ;;    around through successive evaluations.
  1866. ;;
  1867. (defun kill-multiple-values ()
  1868.     [
  1869.         `(clr.l (common-lisp::%multiple-values-address))
  1870.     ])
  1871.  
  1872. (defun compile-nil () 
  1873.     [ `(move.l 'nil d3) ]
  1874.     (setq *last-call-was-values* nil))
  1875.  
  1876. (defun valid-lambda (x)
  1877.     (and (listp x) (> (length x) 2) (eq (car x) 'lambda) (listp (cadr x))))
  1878.  
  1879. (defun find-lambdas (x)
  1880.     (cond ((not (consp x)) nil)
  1881.           ((valid-lambda x) (list x))
  1882.           ((eq (car x) 'FLET) (cdr x))
  1883.           ((eq (car x) 'LABELS) (cdr x))
  1884.           ((eq (car x) 'DEFUN) (list x))
  1885.           ((eq (car x) 'DEFMACRO) (list x))
  1886.           (t (append (find-lambdas (car x)) (find-lambdas (cdr x))))))
  1887.  
  1888. (defun add-lexical-variables (varlist)
  1889.     (push-cleanup (cons 'LET varlist)))
  1890.  
  1891. (defun add-lexical-functions (varlist)
  1892.     (push-cleanup (cons 'FLET varlist)))
  1893.  
  1894. (defun search-lambdas (var lambdas)
  1895.     (cond ((null lambdas) nil)
  1896.           ((eq var lambdas) var)
  1897.           ((atom lambdas) nil)
  1898.           ((search-lambdas var (car lambdas)))
  1899.           ((search-lambdas var (cdr lambdas)))))
  1900.           
  1901. (defun referenced-by-embedded-lambdas (var)
  1902.     (search-lambdas var *embedded-lambdas*))
  1903.     
  1904. (defun create-runtime-bindings ()
  1905.     (if *embedded-lambdas*
  1906.         (dolist (n *cleanup-forms-stack*)
  1907.             (if (or (eq 'LET (car n)) (eq 'FLET (car n)))
  1908.                 (dolist (m (cdr n))
  1909.                     (let* ((sym (car m))
  1910.                            (index (cdr m)))
  1911.                         (if (and (integerp index) 
  1912.                                 (referenced-by-embedded-lambdas sym))
  1913.                             (progn 
  1914.                                 (setf (cdr m) (list index))
  1915.                                 (push sym *environment*)
  1916.                                 [
  1917.                                     ;; add a heap binding for the variable
  1918.                                     `(move.l 0 (-a7))
  1919.                                     `(move.l (a3 ,(* index 4)) (-a7))
  1920.                                     `(move.l ',sym (-a7))
  1921.                                     `(move.l a7 (-a7))
  1922.                                     `(jsr #'cons)
  1923.                                     `(lea (a7 16) a7)
  1924.                                     `(move.l d0 (a3 ,(* index 4)))
  1925.                                 ]))))))))
  1926.  
  1927. ;;
  1928. ;;    export-environment()
  1929. ;;    d3 points to the function to receive the environment
  1930. ;;
  1931. (defun export-environment ()
  1932.     ;; first copy our heap environment
  1933.     [
  1934.         `(move.l 0 (-a7))
  1935.         `(move.l a4 (-a7))        ;; our environment
  1936.         `(move.l d3 (-a7))        ;; target function
  1937.         `(move.l a7 (-a7))
  1938.         `(jsr #'%function-environment)    ;; copy it
  1939.         `(lea (a7 16) a7)
  1940.         
  1941.         ;; now get the target environment in d0
  1942.         `(move.l 0 (-a7))
  1943.         `(move.l d3 (-a7))        ;; target function
  1944.         `(move.l a7 (-a7))
  1945.         `(jsr #'%function-environment)    ;; get its environment
  1946.         `(lea (a7 12) a7)        
  1947.     ]
  1948.     
  1949.     ;; now add all our current heap bindings
  1950.     (if *embedded-lambdas*
  1951.         (dolist (n *cleanup-forms-stack*)
  1952.             (if (eq 'LET (car n))
  1953.                 (dolist (m (cdr n))
  1954.                     (let* ((sym (car m)) 
  1955.                            (index (cdr m)))
  1956.                         (if (consp index)
  1957.                             [
  1958.                                 ;; add the binding to the target environment
  1959.                                 `(move.l d0 (-a7))
  1960.                                 `(move.l 0 (-a7))
  1961.                                 `(move.l (a3 ,(* (car index) 4)) (-a7))
  1962.                                 `(move.l d0 (-a7))
  1963.                                 `(move.l a7 (-a7))
  1964.                                 `(jsr #'%environment-add-binding)
  1965.                                 `(lea (a7 16) a7)
  1966.                                 `(move.l (a7+) d0)
  1967.                             ]))))))
  1968.     (if *embedded-lambdas*
  1969.         (dolist (n *cleanup-forms-stack*)
  1970.             (if (eq 'FLET (car n))
  1971.                 (dolist (m (cdr n))
  1972.                     (let* ((sym (car m)) 
  1973.                            (index (cdr m)))
  1974.                         (if (consp index)
  1975.                             [
  1976.                                 ;; add the binding to the target environment
  1977.                                 `(move.l d0 (-a7))
  1978.                                 `(move.l 0 (-a7))
  1979.                                 `(move.l (a3 ,(* (car index) 4)) (-a7))
  1980.                                 `(move.l d0 (-a7))
  1981.                                 `(move.l a7 (-a7))
  1982.                                 `(jsr #'%environment-add-function-binding)
  1983.                                 `(lea (a7 16) a7)
  1984.                                 `(move.l (a7+) d0)
  1985.                             ])))))))
  1986.  
  1987. )        ;; close beginning eval-when
  1988.  
  1989.  
  1990.  
  1991.  
  1992.  
  1993.  
  1994.  
  1995.  
  1996.  
  1997.  
  1998.  
  1999.  
  2000.  
  2001.  
  2002.  
  2003.  
  2004.  
  2005.  
  2006.  
  2007.  
  2008.  
  2009.  
  2010.  
  2011.  
  2012.  
  2013.  
  2014.  
  2015.  
  2016.  
  2017.  
  2018.  
  2019.  
  2020.  
  2021.